home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 August: Tool Chest / Dev.CD Aug 95 TC / Dev.CD Aug 95 TC.toast / Tool Chest / Development Tools & Languages / Dylan Related / Marlais / Marlais 0.5.9-portable sources / print.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-03-15  |  19.8 KB  |  903 lines  |  [TEXT/ttxt]
  1. /*
  2.  
  3.    print.c
  4.  
  5.    This software is free software; you can redistribute it and/or
  6.    modify it under the terms of the GNU Library General Public
  7.    License as published by the Free Software Foundation; either
  8.    version 2 of the License, or (at your option) any later version.
  9.  
  10.    This software is distributed in the hope that it will be useful,
  11.    but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13.    Library General Public License for more details.
  14.  
  15.    You should have received a copy of the GNU Library General Public
  16.    License along with this software; if not, write to the Free
  17.    Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.    Original copyright notice follows:
  20.  
  21.    Copyright, 1993, Brent Benson.  All Rights Reserved.
  22.    0.4 & 0.5 Revisions Copyright 1994, Joseph N. Wilson.  All Rights Reserved.
  23.  
  24.    Permission to use, copy, and modify this software and its
  25.    documentation is hereby granted only under the following terms and
  26.    conditions.  Both the above copyright notice and this permission
  27.    notice must appear in all copies of the software, derivative works
  28.    or modified version, and both notices must appear in supporting
  29.    documentation.  Users of this software agree to the terms and
  30.    conditions set forth in this notice.
  31.  
  32.  */
  33.  
  34. #include <stdio.h>
  35. #include <string.h>
  36. #include <ctype.h>
  37.  
  38. #include "print.h"
  39.  
  40. #include "character.h"
  41. #include "error.h"
  42. #include "eval.h"
  43. #include "list.h"
  44. #include "prim.h"
  45. #include "slot.h"
  46.  
  47. #ifdef BIG_INTEGERS
  48. #include "biginteger.h"
  49. #endif
  50.  
  51. extern int classic_syntax;
  52.  
  53. /* local function prototypes */
  54.  
  55. static Object print_obj_escaped (Object obj);
  56. static void print_pair (FILE * fp, Object pair, int escaped);
  57. static void print_character (FILE * fp, Object c, int escaped);
  58. static void print_vector (FILE * fp, Object vec, int escaped);
  59. static void print_values (FILE * fp, Object vals, int escaped);
  60. static void print_string (FILE * fp, Object str, int escaped);
  61. static void print_instance (FILE * fp, Object inst, int escaped);
  62. static void print_generic_function (FILE * fp, Object gf, int escaped);
  63. static void print_method (FILE * fp, Object method, int escaped);
  64. static void print_slot_descriptor (FILE * fp, Object slotd, int escaped);
  65. static void print_class (FILE * fp, Object class, int escaped);
  66. static void print_array (FILE * fp, Object array, int escaped);
  67. static void print_stream (FILE * fp, Object stream);
  68. static Object write_char (Object ch, Object stream_list);
  69. static void print_type_name (FILE * fp, Object class, int escaped);
  70.  
  71. /* primitives */
  72.  
  73. static struct primitive print_prims[] =
  74. {
  75.     {"%print", prim_1, print_obj},
  76.     {"%princ", prim_1, print_obj_escaped},
  77.     {"%format", prim_3, format},
  78.     {"%write-char", prim_2, write_char},
  79. };
  80.  
  81. /* function definitions */
  82.  
  83. void
  84. init_print_prims (void)
  85. {
  86.     int num;
  87.  
  88.     num = sizeof (print_prims) / sizeof (struct primitive);
  89.  
  90.     init_prims (num, print_prims);
  91. }
  92.  
  93. void
  94. print_object (FILE * fp, Object obj, int escaped)
  95. {
  96.     switch (TYPE (obj)) {
  97.     case True:
  98.     fprintf (fp, "#t");
  99.     break;
  100.     case False:
  101.     fprintf (fp, "#f");
  102.     break;
  103.     case EmptyList:
  104.     fprintf (fp, classic_syntax ? "()" : "#()");
  105.     break;
  106.     case Integer:
  107.     fprintf (fp, "%d", INTVAL (obj));
  108.     break;
  109. #ifdef BIG_INTEGERS
  110.     case BigInteger:
  111.     print_big_integer (fp, obj);
  112.     break;
  113. #endif
  114.     case Ratio:
  115.     fprintf (fp, "%d/%d", RATIONUM (obj), RATIODEN (obj));
  116.     break;
  117.     case DoubleFloat:
  118.     fprintf (fp, "%f", DFLOATVAL (obj));
  119.     break;
  120.     case Symbol:
  121.     fprintf (fp, "%s", SYMBOLNAME (obj));
  122.     break;
  123.     case Keyword:
  124.     {
  125.         int i;
  126.         char *cp;
  127.  
  128.         fprintf (fp, "#\"");
  129.         cp = KEYNAME (obj);
  130.         for (i = strlen (cp) - 1; i > 0; i--) {
  131.         fputc (*(cp++), fp);
  132.         }
  133.         fputc ('"', fp);
  134.     }
  135.     break;
  136.     case Pair:
  137.     print_pair (fp, obj, escaped);
  138.     break;
  139.     case Character:
  140.     print_character (fp, obj, escaped);
  141.     break;
  142.     case SimpleObjectVector:
  143.     print_vector (fp, obj, escaped);
  144.     break;
  145.     case ByteString:
  146.     print_string (fp, obj, escaped);
  147.     break;
  148.     case ObjectTable:
  149.     fprintf (fp, "{table}");
  150.     break;
  151.     case Deque:
  152.     fprintf (fp, "{deque}");
  153.     break;
  154.     case Array:
  155.     print_array (fp, obj, escaped);
  156.     break;
  157.     case Primitive:
  158.     fprintf (fp, "{primitive function %s}", PRIMNAME (obj));
  159.     break;
  160.     case GenericFunction:
  161.     print_generic_function (fp, obj, escaped);
  162.     break;
  163.     case Method:
  164.     print_method (fp, obj, escaped);
  165.     break;
  166.     case NextMethod:
  167.     fprintf (fp, "next-method()", escaped);
  168.     case Class:
  169.     print_class (fp, obj, escaped);
  170.     break;
  171.     case Instance:
  172.     print_instance (fp, obj, escaped);
  173.     break;
  174.     case Singleton:
  175.     fprintf (fp, "{the singleton ");
  176.     print_object (fp, SINGLEVAL (obj), escaped);
  177.     fprintf (fp, "}");
  178.     break;
  179.     case LimitedIntType:
  180.     fprintf (fp, "{limited <integer>");
  181.     if (LIMINTHASMIN (obj)) {
  182.         fprintf (fp, " min: %d", LIMINTMIN (obj));
  183.     }
  184.     if (LIMINTHASMAX (obj)) {
  185.         fprintf (fp, " max: %d", LIMINTMAX (obj));
  186.     }
  187.     fprintf (fp, "}");
  188.     break;
  189.     case UnionType:
  190.     fprintf (fp, "{union");
  191.     {
  192.         Object ptr;
  193.  
  194.         for (ptr = UNIONLIST (obj); PAIRP (ptr); ptr = CDR (ptr)) {
  195.         fprintf (fp, " ");
  196.         print_object (fp, CAR (ptr), escaped);
  197.         }
  198.         fprintf (fp, "}");
  199.     }
  200.     break;
  201.     case SlotDescriptor:
  202.     print_slot_descriptor (fp, obj, escaped);
  203.     break;
  204.     case EndOfFile:
  205.     fprintf (fp, "{end of file}");
  206.     break;
  207.     case Values:
  208.     print_values (fp, obj, escaped);
  209.     break;
  210.     case Unspecified:
  211.     break;
  212.     case Exit:
  213.     fprintf (fp, "{exit procedure}");
  214.     break;
  215.     case Unwind:
  216.     fprintf (fp, "{unwind protect}");
  217.     break;
  218.     case Stream:
  219.     print_stream (fp, obj);
  220.     break;
  221.     case TableEntry:
  222.     fprintf (fp, "{table entry}");
  223.     break;
  224.     case UninitializedSlotValue:
  225.     fprintf (fp, "{uninitialized slot value}");
  226.     break;
  227.     case DequeEntry:
  228.     fprintf (fp, "{deque entry ", DEVALUE (obj));
  229.     print_object (fp, DEVALUE (obj), escaped);
  230.     fprintf (fp, "}");
  231.     break;
  232.     case ForeignPtr:        /* <pcb> my foreign pointer type. */
  233.     fprintf (fp, "{foreign pointer 0x%08x}", FOREIGNPTR (obj));
  234.     break;
  235.     case Environment:
  236.     fprintf (fp, "{environment object ");
  237.     print_env (ENVIRONMENT (obj));
  238.     fprintf (fp, "}");
  239.     break;
  240.     default:
  241.     error ("print: unknown object type", NULL);
  242.     }
  243. }
  244.  
  245. Object
  246. print_obj (Object obj)
  247. {
  248.     print_object (stdout, obj, 1);
  249.     if (TYPE (obj) != Values || VALUESNUM (obj)) {
  250.     printf ("\n");
  251.     }
  252.     return (unspecified_object);
  253. }
  254.  
  255. static Object
  256. print_obj_escaped (Object obj)
  257. {
  258.     print_object (stdout, obj, 0);
  259.     if (TYPE (obj) != Values || VALUESNUM (obj)) {
  260.     printf ("\n");
  261.     }
  262.     return (unspecified_object);
  263. }
  264.  
  265. void
  266. print_err (Object obj)
  267. {
  268.     print_object (stderr, obj, 1);
  269.     fflush (stderr);
  270. }
  271.  
  272. static void
  273. print_pair (FILE * fp, Object pair, int escaped)
  274. {
  275.     Object cdr;
  276.  
  277.     fprintf (fp, classic_syntax ? "(" : "#(");
  278.     print_object (fp, CAR (pair), escaped);
  279.     cdr = CDR (pair);
  280.     while (PAIRP (cdr)) {
  281.     fprintf (fp, classic_syntax ? " " : ", ");
  282.     print_object (fp, CAR (cdr), escaped);
  283.     cdr = CDR (cdr);
  284.     }
  285.     if (!EMPTYLISTP (cdr)) {
  286.     fprintf (fp, " . ");
  287.     print_object (fp, cdr, escaped);
  288.     }
  289.     fprintf (fp, ")");
  290. }
  291.  
  292. static void
  293. print_character (FILE * fp, Object c, int escaped)
  294. {
  295.     char ch;
  296.  
  297.     ch = CHARVAL (c);
  298.     if (escaped) {
  299.     if (classic_syntax) {
  300.         fprintf (fp, "#\\");
  301.         switch (ch) {
  302.         case '\n':
  303.         fprintf (fp, "newline");
  304.         break;
  305.         case ' ':
  306.         fprintf (fp, "space");
  307.         break;
  308.         case 0x7f:
  309.         fprintf (fp, "rubout");
  310.         break;
  311.         case '\f':
  312.         fprintf (fp, "page");
  313.         break;
  314.         case '\t':
  315.         fprintf (fp, "tab");
  316.         break;
  317.         case '\b':
  318.         fprintf (fp, "backspace");
  319.         break;
  320.         case '\r':
  321.         fprintf (fp, "return");
  322.         break;
  323.         default:
  324.         fprintf (fp, "%c", ch);
  325.         break;
  326.         }
  327.     } else {
  328.         switch (ch) {
  329.         case '\b':
  330.         fprintf (fp, "'\\b'");
  331.         break;
  332.         case '\f':
  333.         fprintf (fp, "'\\f'");
  334.         break;
  335.         case '\n':
  336.         fprintf (fp, "'\\n'");
  337.         break;
  338.         case '\r':
  339.         fprintf (fp, "'\\r'");
  340.         break;
  341.         case '\t':
  342.         fprintf (fp, "'\\r'");
  343.         break;
  344.         default:
  345.         fprintf (fp, "'%c'", ch);
  346.         break;
  347.         }
  348.     }
  349.     } else {
  350.     fprintf (fp, "%c", ch);
  351.     }
  352. }
  353.  
  354. static void
  355. print_vector (FILE * fp, Object vec, int escaped)
  356. {
  357.     int i;
  358.  
  359.     fprintf (fp, "#[");
  360.     for (i = 0; i < SOVSIZE (vec); ++i) {
  361.     print_object (fp, SOVELS (vec)[i], escaped);
  362.     if (i < (SOVSIZE (vec) - 1)) {
  363.         fprintf (fp, ", ");
  364.     }
  365.     }
  366.     fprintf (fp, "]");
  367. }
  368.  
  369. static void
  370. print_slot_values (FILE * fp, Object instance, Object slotds, int escaped)
  371. {
  372.     Object slot_value, slotd;
  373.     int i;
  374.  
  375.     if (EMPTYLISTP (slotds))
  376.     return;
  377.  
  378.     for (i = 0;
  379.      PAIRP (slotds);
  380.      i++, slotds = CDR (slotds)) {
  381.     fprintf (fp, ", ");
  382.     print_object (fp, GFNAME (SLOTDGETTER (CAR (slotds))), escaped);
  383.     fprintf (fp, " = ");
  384.     print_object (fp, CAR (INSTSLOTS (instance)[i]), escaped);
  385.     }
  386. }
  387.  
  388. static void
  389. print_constant_slot_values (FILE * fp, Object const_slotds, int escaped)
  390. {
  391.     Object slotd;
  392.     int i;
  393.  
  394.     if (EMPTYLISTP (const_slotds))
  395.     return;
  396.  
  397.     for (i = 0;
  398.      PAIRP (const_slotds);
  399.      i++, const_slotds = CDR (const_slotds)) {
  400.     slotd = CAR (const_slotds);
  401.     fprintf (fp, ", ");
  402.     print_object (fp, SLOTDGETTER (slotd), escaped);
  403.     fprintf (fp, " = ");
  404.     print_object (fp, SLOTDINIT (slotd), escaped);
  405.     }
  406. }
  407.  
  408. static void
  409. print_virtual_slot_values (FILE * fp, Object instance, Object slotds,
  410.                int escaped)
  411. {
  412.     Object slotd;
  413.  
  414.     if (EMPTYLISTP (slotds))
  415.     return;
  416.  
  417.     for (slotd = CAR (slotds);
  418.      !EMPTYLISTP (slotds);
  419.      slotds = CDR (slotds)) {
  420.     fprintf (fp, ", ");
  421.     print_object (fp, SLOTDGETTER (slotd), escaped);
  422.     fprintf (fp, " = ");
  423.     print_object (fp, eval (listem (SLOTDGETTER (slotd), instance, NULL)),
  424.               escaped);
  425.     }
  426. }
  427.  
  428. static void
  429. print_class_slot_values (FILE * fp, Object class, int escaped, int first)
  430. {
  431.     Object slotds, slots, supers;
  432.     int i;
  433.  
  434.  
  435.     print_slot_values (fp, CLASSCSLOTS (class),
  436.                (first ? append (CLASSCSLOTDS (class),
  437.                     CLASSESSLOTDS (class))
  438.             : CLASSCSLOTDS (class)),
  439.                escaped);
  440.  
  441.     for (supers = CLASSSUPERS (class);
  442.      PAIRP (supers);
  443.      supers = CDR (supers)) {
  444.     print_class_slot_values (fp, CAR (supers), escaped, 0);
  445.     }
  446. }
  447.  
  448. static void
  449. print_instance (FILE * fp, Object inst, int escaped)
  450. {
  451.     Object slots, slot, class, instslotds;
  452.  
  453.     fprintf (fp, "{instance of class %s",
  454.          SYMBOLNAME (CLASSNAME (INSTCLASS (inst))));
  455.     class = INSTCLASS (inst);
  456.  
  457.     instslotds = append (CLASSINSLOTDS (class), CLASSSLOTDS (class));
  458.     print_slot_values (fp, inst, instslotds, escaped);
  459.     print_virtual_slot_values (fp, inst, CLASSVSLOTDS (class), escaped);
  460.     print_class_slot_values (fp, class, escaped, 1);
  461.     print_constant_slot_values (fp, CLASSCONSTSLOTDS (class), escaped);
  462.     fprintf (fp, "}");
  463. }
  464.  
  465. static void
  466. print_values (FILE * fp, Object vals, int escaped)
  467. {
  468.     int i, num;
  469.  
  470.     num = VALUESNUM (vals);
  471. /*  fprintf (fp, "#<"); */
  472.     for (i = 0; i < num; ++i) {
  473.     print_object (fp, VALUESELS (vals)[i], escaped);
  474.     if (i < (num - 1)) {
  475.         fprintf (fp, "\n");
  476.     }
  477.     }
  478. /*  fprintf (fp, ">"); */
  479. }
  480.  
  481. static void
  482. print_param (FILE * fp, Object param, int escaped)
  483. {
  484.     if (SECOND (param) != object_class
  485.     /* || CAR (param) == unspecified_object */
  486.     ) {
  487.     print_object (fp, CAR (param), escaped);
  488.     fprintf (fp, " :: ");
  489.     print_type_name (fp, SECOND (param), escaped);
  490.     } else {
  491.     print_object (fp, CAR (param), escaped);
  492.     }
  493.  
  494. }
  495. static void
  496. print_param_list (FILE * fp, Object params, int escaped)
  497. {
  498.     if (PAIRP (params)) {
  499.     print_param (fp, CAR (params), escaped);
  500.     params = CDR (params);
  501.     while (PAIRP (params)) {
  502.         fprintf (fp, ", ");
  503.         print_param (fp, CAR (params), escaped);
  504.         params = CDR (params);
  505.     }
  506.     }
  507. }
  508.  
  509. static void
  510. print_unparenthesized_list (FILE * fp, Object pair, int escaped)
  511. {
  512.     if (PAIRP (pair)) {
  513.     print_object (fp, CAR (pair), escaped);
  514.     pair = CDR (pair);
  515.     while (PAIRP (pair)) {
  516.         fprintf (fp, " ");
  517.         print_object (fp, CAR (pair), escaped);
  518.         pair = CDR (pair);
  519.     }
  520.     }
  521. }
  522.  
  523. static void
  524. print_generic_function (FILE * fp, Object gf, int escaped)
  525. {
  526.     int some_args_printed = 0;
  527.  
  528.     if (SYMBOLP (GFNAME (gf))) {
  529.     fprintf (fp, "{the generic function %s (", SYMBOLNAME (GFNAME (gf)));
  530.     } else {
  531.     fprintf (fp, "{an anonymous generic function (");
  532.     }
  533.  
  534.     if (PAIRP (GFREQPARAMS (gf))) {
  535.     print_param_list (fp, GFREQPARAMS (gf), escaped);
  536.     some_args_printed = 1;
  537.     }
  538.     if (GFRESTPARAM (gf)) {
  539.     if (some_args_printed) {
  540.         fprintf (fp, ", #rest %s", SYMBOLNAME (GFRESTPARAM (gf)));
  541.     } else {
  542.         fprintf (fp, "#rest %s", SYMBOLNAME (GFRESTPARAM (gf)));
  543.     }
  544.     some_args_printed = 1;
  545.     }
  546.     if (PAIRP (GFKEYPARAMS (gf))) {
  547.     if (some_args_printed) {
  548.         fprintf (fp, ", #key ");
  549.     } else {
  550.         fprintf (fp, "#key ");
  551.     }
  552.     print_unparenthesized_list (fp, GFKEYPARAMS (gf), escaped);
  553.     if (GFALLKEYS (gf)) {
  554.         fprintf (fp, " #, all-keys");
  555.     }
  556.     }
  557.     fprintf (fp, ")}");
  558. }
  559.  
  560. static void
  561. print_method (FILE * fp, Object method, int escaped)
  562. {
  563.     int some_args_printed = 0;
  564.  
  565.     if (METHNAME (method)) {
  566.     fprintf (fp, "{method %s (", SYMBOLNAME (METHNAME (method)));
  567.     } else {
  568.     fprintf (fp, "{an anonymous method (");
  569.     }
  570.     if (PAIRP (METHREQPARAMS (method))) {
  571.     print_param_list (fp, METHREQPARAMS (method), escaped);
  572.     some_args_printed = 1;
  573.     }
  574.     if (METHRESTPARAM (method)) {
  575.     if (some_args_printed) {
  576.         fprintf (fp, ", #rest %s", SYMBOLNAME (METHRESTPARAM (method)));
  577.     } else {
  578.         fprintf (fp, "#rest %s", SYMBOLNAME (METHRESTPARAM (method)));
  579.     }
  580.     some_args_printed = 1;
  581.     }
  582.     if (PAIRP (METHKEYPARAMS (method)) || METHALLKEYS (method)) {
  583.     if (some_args_printed) {
  584.         fprintf (fp, ", #key ");
  585.     } else {
  586.         fprintf (fp, "#key ");
  587.     }
  588.     print_unparenthesized_list (fp, METHKEYPARAMS (method), escaped);
  589.     if (METHALLKEYS (method)) {
  590.         fprintf (fp, ", #all-keys");
  591.     }
  592.     }
  593.     fprintf (fp, ")");
  594.  
  595.     fprintf (fp, "}");
  596. }
  597.  
  598. static void
  599. print_class (FILE * fp, Object class, int escaped)
  600. {
  601.     Object slots, slot;
  602.  
  603.     if (!SYMBOLNAME (CLASSNAME (class))) {
  604.     fprintf (fp, "{an anonymous class");
  605.     } else {
  606.     fprintf (fp, "{the class %s", SYMBOLNAME (CLASSNAME (class)));
  607.     }
  608.  
  609.     /*
  610.        fprintf (fp, " (");
  611.        print_unparenthesized_list (fp, CLASSSUPERS (class), escaped);
  612.        fprintf (fp, ")");
  613.  
  614.        print_slot_values (fp, CLASSCSLOTS(class), append (CLASSCSLOTDS (class),
  615.        CLASSESSLOTDS (class)),
  616.        escaped);
  617.      */
  618.  
  619.     fprintf (fp, "}");
  620.  
  621. }
  622.  
  623. static void
  624. print_slot_descriptor (FILE * fp, Object slotd, int escaped)
  625. {
  626.     fprintf (fp, "{slot descriptor ");
  627.     print_object (fp, SLOTDGETTER (slotd), escaped);
  628.     if (SLOTDALLOCATION (slotd) != instance_symbol) {
  629.     fprintf (fp, " allocation: ");
  630.     print_object (fp, SLOTDALLOCATION (slotd), escaped);
  631.     }
  632.     if (SLOTDSETTER (slotd)) {
  633.     fprintf (fp, " setter: ");
  634.     print_object (fp, SLOTDSETTER (slotd), escaped);
  635.     }
  636.     if (SLOTDSLOTTYPE (slotd) != object_class) {
  637.     if (SLOTDDEFERREDTYPE (slotd)) {
  638.         fprintf (fp, " deferred-type: ");
  639.     } else {
  640.         fprintf (fp, " type: ");
  641.     }
  642.     print_object (fp, SLOTDSLOTTYPE (slotd), escaped);
  643.     }
  644.     if (SLOTDINIT (slotd) != uninit_slot_object) {
  645.     if (SLOTDINITFUNCTION (slotd)) {
  646.         fprintf (fp, " init-function: ");
  647.     } else {
  648.         fprintf (fp, " init: ");
  649.     }
  650.     print_object (fp, SLOTDINIT (slotd), escaped);
  651.     }
  652.     if (SLOTDINITKEYWORD (slotd)) {
  653.     if (SLOTDKEYREQ (slotd)) {
  654.         fprintf (fp, " required-init-keyword: ");
  655.     } else {
  656.         fprintf (fp, " init-keyword: ");
  657.     }
  658.     print_object (fp, SLOTDINITKEYWORD (slotd), escaped);
  659.     }
  660.     fprintf (fp, "}");
  661. }
  662.  
  663. #if 0
  664. static void
  665. print_array (FILE * fp, Object array, int escaped)
  666. {
  667.     fprintf (fp, "{array ");
  668.     print_object (fp, ARRDIMS (array), escaped);
  669.     fprintf (fp, "}");
  670. }
  671.  
  672. #endif
  673.  
  674. static int cur_el;
  675. static void print_array_help (FILE * fp, Object dims, Object *els, int escaped);
  676.  
  677. static void
  678. print_array (FILE * fp, Object array, int escaped)
  679. {
  680.     Object dims, *els;
  681.  
  682.     dims = ARRDIMS (array);
  683.     els = ARRELS (array);
  684.  
  685.     cur_el = 0;
  686.     fprintf (fp, "#%da", list_length (dims));
  687.     print_array_help (fp, dims, els, escaped);
  688. }
  689.  
  690. static void
  691. print_array_help (FILE * fp, Object dims, Object *els, int escaped)
  692. {
  693.     int dim_val, i;
  694.  
  695.     fprintf (fp, "#(");
  696.     dim_val = INTVAL (CAR (dims));
  697.     if (NULLP (CDR (dims))) {
  698.     for (i = 0; i < dim_val; ++i) {
  699.         print_object (fp, els[cur_el++], escaped);
  700.         if (i < (dim_val - 1)) {
  701.         fprintf (fp, " ");
  702.         }
  703.     }
  704.     } else {
  705.     for (i = 0; i < dim_val; ++i) {
  706.         print_array_help (fp, CDR (dims), els, escaped);
  707.     }
  708.     }
  709.     fprintf (fp, ")");
  710. }
  711.  
  712.  
  713.  
  714. #if 0
  715. static void
  716. print_array (FILE * fp, Object array, int escaped)
  717. {
  718.     Object dims;
  719.     unsigned int dim_val, offset, i;
  720.     int rank;
  721.  
  722.     dims = ARRDIMS (array);
  723.     rank = list_length (dims);
  724.     fprintf (fp, "#%da", rank);
  725.     offset = 0;
  726.     while (!NULLP (dims)) {
  727.     fprintf (fp, "(");
  728.     if (NULLP (CDR (dims))) {
  729.         dim_val = INTVAL (CAR (dims));
  730.         for (i = 0; i < dim_val; ++i) {
  731.         print_object (fp, ARRELS (array)[offset], escaped);
  732.         offset++;
  733.         }
  734.     }
  735.     dims = CDR (dims);
  736.     }
  737.  
  738.     while (!NULLP (dims)) {
  739.     fprintf (fp, "(");
  740.     if (NULLP (CDR (dims))) {
  741.         dim_val = INTVAL (CAR (dims));
  742.         for (i = 0; i < dim_val; ++i) {
  743.         print_object (fp, ARRELS (array)[offset], escaped);
  744.         offset++;
  745.         }
  746.     }
  747.     dims = CDR (dims);
  748.     }
  749. }
  750. #endif
  751.  
  752. static void
  753. print_string (FILE * fp, Object str, int escaped)
  754. {
  755.     if (escaped) {
  756.     fprintf (fp, "\"%s\"", BYTESTRVAL (str));
  757.     } else {
  758.     fprintf (fp, "%s", BYTESTRVAL (str));
  759.     }
  760. }
  761.  
  762. Object
  763. format (Object stream, Object str, Object rest)
  764. {
  765.     Object obj;
  766.     FILE *fp;
  767.     char *cstr;
  768.     int i;
  769.  
  770.     if (stream == true_object) {
  771.     fp = stdout;
  772.     } else if (OUTPUTSTREAMP (stream)) {
  773.     fp = STREAMFP (stream);
  774.     } else {
  775.     error ("format: cannot send output to non-stream", stream, NULL);
  776.     }
  777.     cstr = BYTESTRVAL (str);
  778.  
  779.     i = 0;
  780.     while (cstr[i]) {
  781.     if (cstr[i] == '~') {
  782.         i++;
  783.         switch (cstr[i]) {
  784.         case 'a':
  785.         case 'A':
  786.         if (NULLP (rest)) {
  787.             error ("format: not enough args for format string", str, NULL);
  788.         }
  789.         obj = CAR (rest);
  790.         rest = CDR (rest);
  791.         print_object (fp, obj, 0);
  792.         break;
  793.         case 'd':
  794.         case 'D':
  795.         if (NULLP (rest)) {
  796.             error ("format: not enough args for format string", str, NULL);
  797.         }
  798.         obj = CAR (rest);
  799.         if (!INTEGERP (obj)) {
  800.             error ("format: argument to ~d must be an integer", obj, NULL);
  801.         }
  802.         rest = CDR (rest);
  803. #if 0
  804.         if (isdigit (cstr[i - 1])) {
  805.             j = i - 1;
  806.             while (isdigit (cstr[j])) {
  807.             j--;
  808.             }
  809.             j++;
  810.             sscanf (cstr[j], "%d", &arg);
  811.             fprintf (fp, "%");
  812.         } else
  813. #endif
  814.         {
  815.             fprintf (fp, "%d", INTVAL (obj));
  816.         }
  817.         break;
  818.         case 's':
  819.         case 'S':
  820.         if (NULLP (rest)) {
  821.             error ("format: not enough args for format string", str, NULL);
  822.         }
  823.         obj = CAR (rest);
  824.         rest = CDR (rest);
  825.         print_object (fp, obj, 1);
  826.         break;
  827.         case '%':
  828.         fprintf (fp, "\n");
  829.         break;
  830.         case '~':
  831.         fprintf (fp, "~");
  832.         break;
  833.         default:
  834.         /* skip over digits.  individuals branches
  835.            handle there own arguments. */
  836.         if (isdigit (cstr[i])) {
  837.             while (isdigit (cstr[i])) {
  838.             i++;
  839.             }
  840.             break;
  841.         }
  842.         error ("format: bad escape character", make_character (cstr[i]), NULL);
  843.         }
  844.     } else {
  845.         fprintf (fp, "%c", cstr[i]);
  846.     }
  847.     i++;
  848.     }
  849.     if (!NULLP (rest)) {
  850.     error ("format: too many arguments for format string", CAR (rest), NULL);
  851.     }
  852.     return (unspecified_object);
  853. }
  854.  
  855. static void
  856. print_stream (FILE * fp, Object stream)
  857. {
  858.     switch (STREAMSTYPE (stream)) {
  859.     case Input:
  860.     fprintf (fp, "{input stream}");
  861.     break;
  862.     case Output:
  863.     fprintf (fp, "{output stream}");
  864.     break;
  865.     default:
  866.     error ("trying to print stream of unknown type", NULL);
  867.     }
  868. }
  869.  
  870. static Object
  871. write_char (Object ch, Object stream_list)
  872. {
  873.     char the_char;
  874.     FILE *fp;
  875.  
  876.     if (NULLP (stream_list)) {
  877.     fp = stdout;
  878.     } else {
  879.     fp = STREAMFP (CAR (stream_list));
  880.     }
  881.     the_char = CHARVAL (ch);
  882.     fwrite (&the_char, 1, sizeof (char), fp);
  883.  
  884.     return (unspecified_object);
  885. }
  886.  
  887. static void
  888. print_type_name (FILE * fp, Object obj, int escaped)
  889. {
  890.     switch (TYPE (obj)) {
  891.     case Class:
  892.     fprintf (fp, "%s", SYMBOLNAME (CLASSNAME (obj)));
  893.     break;
  894.     case LimitedIntType:
  895.     case UnionType:
  896.     case Singleton:
  897.     print_object (fp, obj, escaped);
  898.     break;
  899.     default:
  900.     error ("print_type_name: object is not a type", obj);
  901.     }
  902. }
  903.